00100	C**** PACKMS.F4 -- TO PACK TOGETHER MANY MS PROGRAM FILES *****
00200	C LOAD WITH [NEW,LCS] MSSIO.FAI
00300		DIMENSION NAMES(635),JEXT(200),JREC(235),
00400		1 FIRST(128),SECOND(4000),INP(72)
00500	C JREC(235) HAS 34 WDS FREE FOR MISC. INFO
00600		EQUIVALENCE(JWDS,FIRST(19)),(KREC,JREC(202)),(JEXT,NAMES(201))
00700		1 ,(JREC,NAMES(401))
00800		IREC=1
00900		JREC(1)=6
01000	15	FORMAT(' P(ACK), U(NPACK), D(IRECTORY)?  '$)
01100	18	TYPE 15
01200		ACCEPT 1,JWDS,K,L
01300		IPU=0
01400		MORE=0
01500		IF(JWDS.EQ.'P')GO TO 2
01600		INF=-1
01700		IPU=-1
01800		IF(JWDS.EQ.'D')	IPU=-IPU
01900	C PACK=0,  UNPACK=-1, DIRECTORY=1
02000	16	FORMAT(' TYPE PACK FILE NAME AND EXT.(DEFAULT EXT=.PAK)  '$)
02100	17	TYPE 16
02200		ACCEPT 1,INP
02300		X=' '
02400		CALL NAMEXT(INP,IPAK,X)
02500		IF(INP(1).EQ.' ')IPAK=JPAK
02600		JPAK=IPAK
02700		IF(X.EQ.' ')X='PAK'
02800		IF(LOOKX(IPAK,X).EQ.0)GO TO 17
02900		IF(IPU.GT.0)GO TO 113
03000	1	FORMAT(72A1)
03100	2	IF(IPU.LT.0)GO TO 41
03150		TYPE 3
03175		GO TO 42
03187	41	TYPE 40
03200	3	FORMAT(' TYPE FIRST NAME AND EXT.(DEFAULT EXT=.MS)  '$)
03220	40	FORMAT(' TYPE FIRST NAME AND EXT.(DEFAULT EXT=.MS) OR "ALL"  '$)
03300	4	FORMAT(' TYPE LAST NAME OR "ALL" (NO EXT, <CR>=1 FILE ONLY)  '$)
03400	42	ACCEPT 1,INP
03500		KEXT=' '
03600		CALL NAMEXT(INP,NAME,KEXT)
03700		IF(KEXT.EQ.' ')KEXT='MS'
03800		IF(IPU.LT.0.AND.NAME.EQ.'ALL')GO TO 122
03900		IF(IPU.LT.0)GO TO 19
04000		IF(LOOKX(NAME,KEXT).EQ.0)GO TO 2 
04100	19	TYPE 4
04200		ACCEPT 1,INP
04300		NAME2=' '
04400		X2=' '
04500		CALL NAMEXT(INP,NAME2,X2)
04600		IF(NAME2.EQ.' ')NAME2=NAME
04700		IF(X2.EQ.' ')X2=KEXT
04800		IF(X2.NE.KEXT)GO TO 18
04900		IF(IPU.LT.0)GO TO 121
04950		IF(NAME2.EQ.'ALL')NAME2='99999'
05000	12	IF(MORE.LT.0)GO TO 21
05100		TYPE 16
05200		ACCEPT 1,INP
05300		X=' '
05400		CALL NAMEXT(INP,IPAK,X)
05500		IF(X.EQ.' ')X='PAK'
05600	13	IF(LOOKX(IPAK,X).EQ.0)GO TO 10
05700		TYPE 11
05800	11	FORMAT(' WRITE OVER THAT NAME?  '$)
05900		ACCEPT 1,INP
06000		IF(INP(1).NE.'Y')GO TO 12
06100	10	CALL PUTEXT(IPAK,X)
06200		CALL EXTOUT(NAMES,635)
06300	C COME BACK AND FILL UP THE HEADER LATER.
06400	21	NM=NAME
06500		MORE=0
06600	20	NMX=NM
06800		NMZ=NM
07000	6	IF(LOOKX(NM,KEXT).EQ.0)GO TO 1000
07100	C JUMP IF NOT FOUND
07200	7	CALL GETEXT(NM,KEXT)
07300		CALL EXTIN(FIRST,128)
07400		CALL EXTIN(SECOND,JWDS)
07500		CALL EXTOUT(FIRST,128)
07600		CALL EXTOUT(SECOND,JWDS)
07700		TYPE 9,NM,KEXT
07800		NAMES(IREC)=NM
07900		JEXT(IREC)=KEXT
08000		KREC=IREC
08100		IREC=IREC+1
08200		JREC(IREC)=JREC(IREC-1)+2+(JWDS-1)/128
08300	C SAVE FOR USETI
08400		IF(IREC.LT.201)NAMES(IREC)=0
08500	14	IF(NM.EQ.NAME2.OR.IREC.EQ.200)GO TO 2000
08600	C LIMIT OF 200 FILES AT THIS TIME.
08700		NM=NM+2
08800		GO TO 6
08900	1000	NM=NMX+256
08920	C UPDATE 4TH CHAR.  (E.G. AAAAA TO AAABA)
09000		NMX=NM
09100		IF(LOOKX(NM,KEXT).LT.0)GO TO 7
09200		NM=NMZ+32768
09220	C UPDATE 3RD CHAR. (E.G. AAAAA TO AABAA)
09300		NMX=NM
09400		NMZ=NM
09500		IF(LOOKX(NM,KEXT).LT.0)GO TO 7
09600	C NOW ALL DONE.  REBUILD HEADER.
09700	2001	FORMAT(' ADD MORE TO FILE?  '$)
09800	2000	TYPE 2001
09900		ACCEPT 1,K
10000		MORE=-1
10100		IF(K.EQ.'Y')GO TO 2
10200		CALL USTO(1)
10300		CALL EXTOUT(NAMES,635)
10400		CALL FINEXT
10500		TYPE 8,IPAK,X,KREC
10600		CALL EXIT
10700	8	FORMAT(' ***** ALL DONE WRITING ',A5,'.',A3/5XI3,' FILES')
10800	9	FORMAT(1XA5,'.',A3)
11000	122	IPU=4
11200	121	TYPE 111
11300	111	FORMAT(' CHANGE EXTENSION TO -- (<CR>=NO CHANGE)  '$)
11400	112	FORMAT(A3)
11500		ACCEPT 112,NEXT
11600		IF(NEXT.NE.' ')KEXT=NEXT
11700	113	CALL GETEXT(IPAK,X)
11800		CALL EXTIN(NAMES,635)
11900		IF(IPU.LE.0)GO TO 114
12000		GO TO(109,2,118,3000)IPU
12100	118	GO TO 18
12200	115	FORMAT(' TYPE NEW NAME AND EXT.  '$)
12300	119	MEXT=' '
12400		TYPE 115
12500		ACCEPT 1,INP
12600		CALL NAMEXT(INP,NAME2,MEXT)
12700		IF(MEXT.EQ.' ')MEXT=KEXT
12800		NMX=0
12900		DO 116 K=1,200
13000		NN=NAMES(K)
13100		MM=JEXT(K)
13200		IF(NAME.EQ.NN.AND.KEXT.EQ.MM)NMX=K
13300	116	IF(NAME2.EQ.NN.AND.MEXT.EQ.MM)GO TO 117
13400		IF(NMX.NE.0)GO TO 120
13500		TYPE 102
13600		CALL EXIT
13700	120	NAMES(NMX)=NAME2
13800		JEXT(NMX)=MEXT
13900		CALL EXIT
14000	CCCC GO WRITE NEW FORM OF .PAK FILE	GO TO ????
14100	117	TYPE 11
14200		ACCEPT 1,JWDS
14300		IF(JWDS.NE.'Y')GO TO 18
14400	114	NM=NAME
14500		NN=NM
14600	105	DO 101 K=1,200
14700	101	IF(NAMES(K).EQ.NAME)GO TO 108
14800		NAME=NM+256
14900		NM=NAME
15000		DO 107 K=1,200
15100	107	IF(NAMES(K).EQ.NAME)GO TO 108
15200		NAME=NN+32768
15300		NN=NAME
15350		NM=NN
15400		DO 177 K=1,200
15500	177	IF(NAMES(K).EQ.NAME)GO TO 108
15600	106	IF(INF.NE.0)TYPE 102
15700		GO TO 18
15800	102	FORMAT(' FILE NOT FOUND')
16000	108	CALL USTI(JREC(K))
16100		CALL EXTIN(FIRST,128)
16200		CALL EXTIN(SECOND,JWDS)
16300		TYPE 9,NAME,KEXT
16400		INF=0
16500	104	IF(LOOKX(NAME,KEXT).EQ.0)GO TO 103
16600	C IS FILE ALREADY ON DSK?
16700		TYPE 11
16800		ACCEPT 1,K
16900		IF(K.EQ.'Y')GO TO 103
17000		TYPE 3   
17100		ACCEPT 1,INP
17200		CALL NAMEXT(INP,NAME,KEXT)
17300		GO TO 104
17400	103	CALL PUTEXT(NAME,KEXT)
17500		CALL EXTOUT(FIRST,128)
17600		CALL EXTOUT(SECOND,JWDS)
17700		CALL FINEXT
17800		IF(NAME.EQ.NAME2)CALL EXIT
17900		NAME=NAME+2
18000		GO TO 105
18100	3004	FORMAT(3XI3,' FILES'/)
18200	109	TYPE 3004,KREC
18300		 DO 110 K=1,200
18400		IF(NAMES(K).EQ.0)GO TO 18
18500	110	TYPE 9,NAMES(K),JEXT(K)
18600		GO TO 18
18700	3000	DO 3001 K=1,200
18800		NM=NAMES(K)
18900		IF(NM.EQ.0)CALL EXIT
19000		MM=JEXT(K)
19100		IF(NEXT.NE.' ')MM=NEXT
19200		CALL EXTIN(FIRST,128)
19300		CALL EXTIN(SECOND,JWDS)
19400		TYPE 9,NM,MM
19500	3003	IF(LOOKX(NM,MM).EQ.0)GO TO 3002
19600		TYPE 11
19700		ACCEPT 1,L
19800		IF(L.NE.'Y')GO TO 3001
19900	3002	CALL PUTEXT(NM,MM)
20000		CALL EXTOUT(FIRST,128)
20100		CALL EXTOUT(SECOND,JWDS)
20200		CALL FINEXT
20300	3001	CONTINUE
20400		END
20500	
20600		SUBROUTINE NAMEXT(I,NAME,IEXT)
20700	C FINDS NAME.EXT IN A1 STRING
20800		DIMENSION I(1)
20900	
21000		IF(I(1).NE.-1)GO TO 9
21100	C FIRST PASS UP 'G', 'GM', 'RS', ETC.  (=-1)
21200		DO 1 K=1,72
21300	1	IF(I(K).EQ.' ')GO TO 2
21400	C NOW PASS BLANKS
21500	2	J=72
21600		DO 3 J=K+1,72
21700	3	IF(I(J).NE.' ')GO TO 4
21800	C NOW FOUND START OF WORD (UNLESS ALL BLANKS)
21900	4	IF(J.NE.72)GO TO 5
22000		NAME=' '
22100		RETURN
22200	9	J=1
22300	5	DO 6 K=J,72
22400		IF(I(K).EQ.' ')GO TO 7
22500	C JUMP IF NAME ONLY
22600	6	IF(I(K).EQ.'.')GO TO 8
22700	7	CALL PACKX(NAME,I(J))
22800		RETURN
22900	8	CALL RLOOP(I(61),I(J),K-J)
23000		CALL PACKX(NAME,I(61))
23100		CALL PACKX(IEXT,I(K+1))
23200		END
23300	
23400		SUBROUTINE PACKX(NAM,KNM)
23500		DIMENSION KNM(5)
23600		DATA KK/128/,LL/"377777777777/,JJ/"2000000000/
23700		1 , MM/"774000000000/
23800		NAM=0
23900		DO 12 K=5,1,-1
24000		NAM=NAM .OR. (KNM(K) .AND. MM)
24100		IF (K.EQ.1)RETURN
24200	17	IF (NAM.GE.0)GO TO 13
24300		NAM = (( NAM .AND. LL)/KK) .OR. JJ
24400		GO TO 12
24500	13	NAM = NAM / KK
24600	12	CONTINUE
24700		RETURN
24800		END